(*
 *  MTASC - MotionTwin ActionScript2 Compiler
 *  Copyright (c)2004 Nicolas Cannasse
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *)
open Expr
open TyperInc

let type_function_ref = ref (fun ?lambda _ -> assert false)

let rec type_binop ctx op v1 v2 p =
	let t1 = type_val ctx v1 in
	let t2 = type_val ctx v2 in
	no_void t1 (pos v1);
	no_void t2 (pos v2);
	let rec loop = function
		| OpAdd ->
			if t1 == Dyn || t2 == Dyn then
				Dyn
			else if is_number ctx t1 && is_number ctx t2 then
				ctx.inumber
			else
				ctx.istring
		| OpAnd
		| OpOr
		| OpXor
		| OpShl
		| OpShr
		| OpUShr
		| OpMod
		| OpMult | OpDiv | OpSub ->
			unify t1 ctx.inumber p;
			unify t2 ctx.inumber p;
			ctx.inumber
		| OpAssign ->
			unify_array t2 t1 v2 p;
			t1
		| OpEq
		| OpPhysEq
		| OpPhysNotEq
		| OpNotEq
		| OpGt
		| OpGte
		| OpLt
		| OpLte ->
			ctx.ibool
		| OpBoolAnd
		| OpBoolOr ->
			tcommon ctx t1 t2 p
		| OpAssignOp op ->
			let t = loop op in
			unify t t1 p;
			t1
	in
	loop op

and type_val ?(in_field=false) ctx ((v,p) as e) =
	match v with
	| EConst c -> 
		(match type_constant ctx c e p with
		| Package pk when not in_field -> resolve_package ctx e pk p
		| t -> t)
	| ECast (v1,v2) ->
		let t = type_val ctx v1 in
		ignore(type_val ctx v2);
		(match t with
		| Static c -> Class c
		| _ -> error (Custom "Casting to not a class") (pos v1))
	| EArray (v1,v2) -> 
		let t = type_val ctx v1 in
		ignore(type_val ctx v2);
		(match t with
		| Class { param = Some c } -> Class c
		| _ -> Dyn)
	| EBinop (op,v1,v2) ->
		type_binop ctx op v1 v2 p
	| EField (v,f) ->
		let t = type_val ~in_field:true ctx v in
		let t = (match type_field ctx t f p with
		| Package pk when not in_field -> resolve_package ctx e pk p
		| t -> t) in
		(match e with
		| EField ((EStatic p , pos) as v,_) , _ when f <> "prototype" && fst p <> ["__With"] -> 
			let rec loop cl =
				if Hashtbl.mem cl.statics f then
					cl.path
				else if cl.super == cl then
					p
				else
					loop cl.super
			in
			let p = loop (!load_class_ref ctx p pos) in
			set_eval v (EStatic p);
		| _ -> ());
		t
	| EStatic cpath ->
		let c = resolve_path ctx cpath p in
		set_eval e (EStatic c.path);
		Static c
	| EParenthesis v ->
		type_val ctx v
	| EObjDecl vl ->
		List.iter (fun (_,v) -> no_void (type_val ctx v) (pos v)) vl;
		Class (t_object ctx)
	| EArrayDecl vl ->
		List.iter (fun v -> no_void (type_val ctx v) (pos v)) vl;
		Class (t_array ctx)
	| ECall ((EConst (Ident "super"),_),args) ->
		if not ctx.in_constructor then error (Custom "Super constructor can only be called in class constructor") p;
		let args = List.map (type_val ctx) args in
		(match ctx.current.super.constructor with
		| None -> ()
		| Some t ->
			unify (Function (args,Void)) t.f_type p);
		Void
	| ECall (v,args) ->
		let t = type_val ctx v in
		(match t with
		| Function (fargs,ret) ->
			let rec loop l1 l2 =
				match l1 , l2 with
				| [] , _ -> ()
				| l , [] ->
					List.iter (fun v -> ignore(type_val ctx v)) l
				| v :: l1 , a :: l2 ->
					unify (type_val ctx v) a (pos v);
					loop l1 l2
			in
			loop args fargs;
			ret
		| Dyn ->
			List.iter (fun v -> no_void (type_val ctx v) (pos v)) args;
			Dyn
		| Class cl when is_function cl ->
			List.iter (fun v -> no_void (type_val ctx v) (pos v)) args;
			Dyn
		| Static c when List.length args = 1 ->
			ignore(type_val ctx (List.hd args));
			set_eval e (ECast (v,List.hd args));
			Class c
		| _ -> 
			error (Custom ("Cannot call non-function object " ^ s_type_decl t)) (pos v));
	| EQuestion (v,v1,v2) ->
		no_void (type_val ctx v) (pos v);
		let t1 = type_val ctx v1 in
		let t2 = type_val ctx v2 in
		tcommon ctx t1 t2 p
	| EUnop (Not,_,v) ->
		no_void (type_val ctx v) (pos v);
		ctx.ibool
	| EUnop (_,_,v) ->
		unify (type_val ctx v) ctx.inumber (pos v);
		ctx.inumber
	| ENew (v,vl) ->
		let args = List.map (type_val ctx) vl in
		(match type_val ctx v with
		| Static cl ->
			(match cl.constructor with
			| None -> ()
			| Some t ->
				if t.f_public = IsPrivate && not (is_super cl ctx.current) then error (Custom "Cannot call private constructor") p;
				unify (Function (args,Dyn)) t.f_type p);
			Class cl
		| Dyn ->
			Dyn
		| Class cl when is_function cl ->
			Dyn
		| t ->
			error (Custom ("Invalid type : " ^ s_type_decl t ^ " for new call")) p)
 	| ELambda f ->
		!type_function_ref ~lambda:true ctx (t_object ctx) f p

let rec type_expr ctx (e,p) =
	match e with
	| EVars (_,_,vl) ->
		List.iter (fun (name,tt,v) -> 
			let t = (if !local_inference && v <> None && tt = None then Dyn else t_opt ctx p tt) in
			let t = (match v with
				| None -> t 
				| Some v -> 
					let tv = type_val ctx v in
					unify_array tv t v (pos v);
					if !local_inference && tt = None then tv else t
			) in
			define_local ctx name t p			
		) vl
	| EFunction f ->
		assert false
	| EBlock el ->
		let f = new_frame ctx in
		List.iter (type_expr ctx) el;
		clean_frame ctx f
	| EFor (inits,conds,incrs,e) ->
		let f = new_frame ctx in
		List.iter (type_expr ctx) inits;
		List.iter (fun v ->
			no_void (type_val ctx v) (pos v)
		) conds;
		List.iter (fun v ->
			ignore(type_val ctx v)
		) incrs;
		type_expr ctx e;
		clean_frame ctx f
	| EForIn (decl,v,e) ->
		let f = new_frame ctx in
		(match decl with
		| EVal ((EConst (Ident x),_) as v) , p ->
			let t = type_val ctx v in
			unify ctx.istring t p;
			unify t ctx.istring p;
		| EVars (_,_,[x,t,None]) , p ->
			unify ctx.istring (t_opt ctx p t) p;
			define_local ctx x ctx.istring p
		| _ ->
			error (Custom "Invalid forin parameter") p);
		no_void (type_val ctx v) (pos v);
		type_expr ctx e;
		clean_frame ctx f
	| EIf (v,e,eo) ->
		no_void (type_val ctx v) (pos v);
		type_expr ctx e;
		(match eo with None -> () | Some e -> type_expr ctx e);
	| EWhile (v,e,_) ->
		no_void (type_val ctx v) (pos v);
		type_expr ctx e
	| ESwitch (v,cases) ->
		let t = type_val ctx v in
		List.iter (fun (v,e) ->
			(match v with
			| None -> ()
			| Some v ->
				unify (type_val ctx v) t (pos v));
			type_expr ctx e
		) cases;
	| ETry (etry,cl,fo) ->
		type_expr ctx etry;
		let no_type = ref false in
		cl := List.map (fun (name,t,e) -> 
			if !no_type then error (Custom "Misplaced catch will fail to catch any exception") (pos e);
			let t2 = (match t with None -> no_type := true; None | Some c -> Some (resolve_path ctx c p).path ) in
			let f = new_frame ctx in
			define_local ctx name (t_opt ctx p t) p;
			type_expr ctx e;
			clean_frame ctx f;
			name , t2 , e
		) !cl;
		(match fo with None -> () | Some e -> type_expr ctx e)
	| EWith (v,e) ->
		let old_with = ctx.curwith in
		let t = type_val ctx v in
		(match t with
		| Void
		| Static _ -> error (Custom "Invalid type for 'with' argument") p
		| Package _ -> assert false
		| Dyn
		| Function _
		| Class _ -> ());
		ctx.curwith <- Some t;
		ignore(type_expr ctx e);
		ctx.curwith <- old_with;
	| EReturn None ->
		if ctx.returns <> Void && ctx.returns <> Dyn then error (Custom "Return type cannot be Void") p;
	| EReturn (Some v) ->
		unify (type_val ctx v) ctx.returns (pos v)
	| EBreak
	| EContinue ->
		()
	| EVal v ->
		ignore(type_val ctx v)

let type_function ?(lambda=false) ctx clctx f p =
	match f.fexpr with
	| None -> assert false
	| Some e ->
		if not lambda then verbose_msg ("Typing " ^ s_type_path clctx.path ^ "." ^ f.fname);
		let ctx = {
			ctx with
				current = if lambda then { clctx with imports = ctx.current.imports; native = false; } else clctx;
				locals = if lambda then ctx.locals else Hashtbl.create 0;
				in_static = (f.fstatic = IsStatic);
				in_constructor = (f.fstatic = IsMember && f.fname = clctx.name);
				in_lambda = (if lambda then (match ctx.in_lambda with None -> Some ctx.current | Some _ -> ctx.in_lambda) else None);
				curwith = None;
		} in
		let fr = new_frame ctx in
		ctx.returns <- ret_opt ctx p f;
		let argst = List.map (fun (a,t) -> 
			let t = t_opt ctx p t in
			define_local ctx a t p;
			t
		) f.fargs in
		type_expr ctx e;
		clean_frame ctx fr;
		Function (argst,ctx.returns)


let rec type_class_fields ctx clctx comp (e,p) =
	match e with
	| EBlock el -> List.iter (type_class_fields ctx clctx comp) el
	| EVars (stat,pub,vl) ->
		if clctx.interface then error (Custom "Interface cannot contain variable declaration") p;
		List.iter (fun (vname,vtype,vinit) ->
			let t = t_opt ctx p vtype in
			add_class_field ctx clctx vname stat pub Normal t p;
			match vinit with
			| None -> ()
			| Some v ->
				if not comp then add_finalizer ctx (fun () -> 
					ctx.current <- clctx;
					unify (type_val ctx v) t p
				)
		) vl
	| EFunction f -> 
		let t = Function (List.map (fun (_,t) -> t_opt ctx p t) f.fargs , ret_opt ctx p f) in
		if f.fname = snd clctx.path then begin
			if f.ftype <> None then error (Custom "Constructor return type should not be specified") p;
			if clctx.interface then error (Custom "Interface can't have a constructor") p;
			match clctx.constructor with
			| None -> clctx.constructor <- Some { f_name = f.fname;	f_type = t; f_static = IsMember; f_public = f.fpublic; f_pos = null_pos }
			| Some _ -> error (Custom "Duplicate constructor") p;
		end else
			add_class_field ctx clctx f.fname f.fstatic f.fpublic f.fgetter t p;
		if f.fexpr <> None && not comp then add_finalizer ctx (fun () -> ignore(type_function ctx clctx f p));
	| _ ->
		assert false

let type_class ctx cpath herits e imports file interf native s =
	let old = ctx.current in
	let rec clctx = {
		path = cpath;
		param = None;
		name = snd cpath;
		file = file;
		native = native;
		interface = interf;
		dynamic = List.exists ((=) HDynamic) herits;
		fields = Hashtbl.create 0;
		statics = Hashtbl.create 0;
		constructor = None;
		super = clctx;
		implements = [];
		imports = imports;
	} in
	Hashtbl.add imports.paths clctx.name { imp_path = clctx.path; imp_used = true; imp_pos = pos s };
	if Hashtbl.mem ctx.classes cpath then error (Custom ("Redefinition of class " ^ s_type_path cpath ^ ", please check using -v that the file is not referenced several times")) (pos s);
	Hashtbl.add ctx.classes cpath clctx;
	ctx.current <- clctx;
	let herits = List.map (function
		| HExtends cpath -> HExtends (resolve_path ctx cpath (pos e)).path
		| HImplements cpath -> HImplements (resolve_path ctx cpath (pos e)).path
		| HDynamic
		| HIntrinsic as x -> x
	) herits in
	let is_component = !use_components && (match clctx.path with ("mx" :: _ , _) -> true | _ -> false) in
	let herits = (if is_component then HIntrinsic :: herits else herits) in
	Obj.set_field (Obj.repr s) 0 (Obj.repr (if interf then EInterface (cpath,herits,e) else EClass (cpath,herits,e)));
	let rec loop flag = function
		| [] -> t_object ctx
		| HExtends cpath :: l -> 
			if flag then error (Custom "Multiple inheritance is not allowed") (pos e);
			let cl = resolve_path ctx cpath (pos e) in
			if clctx.interface && not cl.interface then error (Custom "Interface cannot extends a class") (pos e);
			ignore(loop true l);
			cl
		| _ :: l -> loop flag l
	in	
	clctx.super <- loop false herits;
	if clctx.super.interface && not clctx.interface then error (Custom "Cannot extends an interface") (pos e);
	let rec loop = function
		| [] -> []
		| HImplements cpath :: l -> cpath :: loop l
		| _ :: l -> loop l
	in
	clctx.implements <- List.map (fun cpath -> 
		let c = resolve_path ctx cpath (pos e) in
		if clctx.interface then error (Custom "Interface cannot implements another interface, use extends") (pos e);
		if not c.interface then error (Custom "Cannot implements a class") (pos e);
		c
	) (loop herits);
	type_class_fields ctx clctx is_component e;
	ctx.current <- old;
	clctx

let type_file ctx req_path file el pos =
	let clctx = ref None in
	let imports = {
		paths = Hashtbl.create 0;
		wildcards = [];
	} in
	let clerror t p =
		if pos = argv_pos then
			()
		else if String.lowercase (s_type_path req_path) = String.lowercase (s_type_path t) then begin
			Hashtbl.remove ctx.files file;
			error (Class_not_found req_path) pos
		end else begin
			let a = Array.to_list (Sys.readdir (Filename.dirname file)) in
			let f = Filename.basename file in
			if List.exists ((=) f) a then
				error (Class_name_mistake req_path) p
			else
				error (Class_name_mistake t) pos
		end
	in
	List.iter (fun ((s,p) as sign) ->
		match s with
		| EClass (t,hl,e) ->
			if t <> req_path then clerror t (snd e);
			if !clctx <> None then error (Custom "Cannot declare several classes in same file") p;
			clctx := Some (type_class ctx t hl e imports file false (List.exists ((=) HIntrinsic) hl) sign)
		| EInterface (t,hl,e) ->
			if t <> req_path then clerror t (snd e);
			if !clctx <> None then error (Custom "Cannot declare several classes in same file") p;
			clctx := Some (type_class ctx t hl e imports file true false sign)
		| EImport (path,Some name) ->
			if Hashtbl.mem imports.paths name then error (Custom "Duplicate Import") p;
			Hashtbl.add imports.paths name { imp_path = (path,name); imp_pos = p; imp_used = false }
		| EImport (pk,None) ->
			imports.wildcards <- { wimp_path = pk; wimp_pos = p; wimp_used = false } :: imports.wildcards
	) el;
	if !warn_imports && (not !use_components || (match !clctx with Some { path = "mx" :: _ , _ } -> false | _ -> true)) then
		add_finalizer ctx (fun () ->
			Hashtbl.iter (fun _ imp -> if not imp.imp_used then (!ParserInc.warning) "import not used" imp.imp_pos) imports.paths;
			List.iter (fun imp -> if not imp.wimp_used then (!ParserInc.warning) "import not used" imp.wimp_pos) imports.wildcards;
		);
	!clctx

let load_file ctx file =	
	let rec loop = function
		| [] -> raise (File_not_found file)
		| path :: paths ->
			try
				let file = path ^ file in
				file , open_in file
			with
				_ -> loop paths
	in
	let file, ch = loop ctx.class_path in
	let expr, comments = (try
		Parser.parse (Lexing.from_channel ch) file
	with
		| exc ->
			close_in ch;
			raise exc
	) in
	close_in ch;
	List.iter check_sign expr;
	Hashtbl.add ctx.files file expr;
	verbose_msg ("Parsed " ^ file);
	file , expr

let rec load_class ctx path p =
	match path with
	| [param] , "Array" when param.[0] == '#' ->
		let cl = load_class ctx ([],"ArrayPoly") p in
		let path2 = ExtString.String.nsplit (String.sub param 1 (String.length param - 1)) "." in
		let rec loop acc = function
			| [] -> assert false
			| [x] -> List.rev acc , x
			| x :: l -> loop (x :: acc) l
		in
		let path2 = loop [] path2 in
		let cl2 = resolve_path ctx path2 p in
		let arr = { cl with
			path = path;
			param = Some cl2;
			fields = Hashtbl.create 0;
			statics = Hashtbl.create 0;
			implements = [];
			constructor = None;
		} in
		let rec map_type = function
			| Class { path = ([],"ArrayParam") } -> Class cl2
			| Class { path = (["#ArrayParam"],"Array") } -> Class arr
			| Function (params,ret) -> Function (List.map map_type params,map_type ret)
			| t -> t
		in
		Hashtbl.iter (fun s f ->
			Hashtbl.add arr.fields s { f with f_type = map_type f.f_type }
		) cl.fields;
		arr
	| _ ->
	try
		Hashtbl.find ctx.classes path
	with
		Not_found ->
			if String.lowercase (snd path) = "con" then error (Custom "CON is a special file under Windows and shouldn't be used as class name") p;
			let file_name = (match fst path with
				 | [] -> snd path ^ ".as"
				 | _ -> String.concat "/" (fst path) ^ "/" ^ snd path ^ ".as")
			in
			try
				let f , e = load_file ctx file_name in
				match type_file ctx path f e p with
				| None -> error (Custom "Missing class definition") { pfile = file_name; pmin = 0; pmax = 0 }
				| Some c -> c
			with
				File_not_found _ -> error (Class_not_found path) p

let check_interfaces ctx =
	Hashtbl.iter (fun _ clctx ->
		let cli = Class clctx in
		let rec loopeq variance t1 t2 =
			match t1, t2 with
			| Void , Void -> true
			| Dyn , _ -> true
			| Class cl1 , Class cl2 -> 
				if cl1.path = cl2.path then
					true
				else
				let t = (try tcommon ctx (Class cl1) (Class cl2) null_pos with _ -> Dyn) in				
				(match t with				
				| Class c when c.path = cl1.path -> variance
				| Class c when c.path = cl2.path -> not variance
				| _ -> false)
			| Function (a1,r1) , Function (a2,r2) when List.length a1 = List.length a2 -> List.for_all2 (loopeq true) a1 a2 && loopeq false r1 r2
			| _ , _ -> false
		in
		let rec loop_interf = function
			| i :: l -> loop_fields i; loop_interf l
			| [] -> ()
		and loop_fields i =
			if i.super.interface then loop_fields i.super;
			Hashtbl.iter (fun _ f ->
				if f.f_static = IsMember then
					match resolve cli f.f_name with
					| None -> error (Custom ("Missing field " ^ f.f_name ^ " required by " ^ s_type_path i.path)) { pfile = clctx.file; pmin = 0; pmax = 0 }
					| Some f2 -> 
						if f2.f_public = IsPrivate then error (Custom ("Field " ^ f.f_name ^ " is declared in an interface and should be public")) f2.f_pos;
						unify f2.f_type f.f_type f2.f_pos;
						if not (loopeq true f.f_type f2.f_type) then error (Custom ("Field " ^ f.f_name ^ " type is different from the one defined in " ^ s_type_path i.path)) f2.f_pos
			) i.fields
		in
		loop_interf clctx.implements;
	) ctx.classes

let create cpath = 
	let ctx = {
		current = Obj.magic();
		inumber = Obj.magic();
		ibool = Obj.magic();
		istring = Obj.magic();
		finalizers = ref [];
		class_path = cpath;
		files = Hashtbl.create 0;
		classes = Hashtbl.create 0;
		in_static = true;
		in_lambda = None;
		in_constructor = false;
		returns = Void;
		curwith = None;
		locals = Hashtbl.create 0;
		frame = 0;
	} in
	ignore(load_class ctx ([],"StdPresent") null_pos);
	ctx.inumber <- Class (load_class ctx ([],"Number") null_pos);
	ctx.ibool <- Class (load_class ctx ([],"Boolean") null_pos);
	ctx.istring <- Class (load_class ctx ([],"String") null_pos);
	ctx

let rec finalize ctx =
	let fl = List.rev !(ctx.finalizers) in
	ctx.finalizers := [];
	match fl with
	| [] -> 
		check_interfaces ctx
	| _ ->
		List.iter (fun f -> f()) fl;
		finalize ctx

let exprs ctx = ctx.files

;;
load_class_ref := load_class;
type_function_ref := type_function